home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / src / cmds / perl / sprite / RCS / perldb.pl,v < prev    next >
Encoding:
Text File  |  1991-11-14  |  18.6 KB  |  724 lines
  1. head     1.4;
  2. branch   ;
  3. access   ;
  4. symbols  ;
  5. locks    ; strict;
  6. comment  @@;
  7.  
  8.  
  9. 1.4
  10. date     91.11.14.12.52.10;  author jhh;  state Exp;
  11. branches ;
  12. next     1.3;
  13.  
  14. 1.3
  15. date     91.08.20.14.27.28;  author jhh;  state Exp;
  16. branches ;
  17. next     1.2;
  18.  
  19. 1.2
  20. date     91.08.12.16.42.06;  author jhh;  state Exp;
  21. branches ;
  22. next     1.1;
  23.  
  24. 1.1
  25. date     91.07.29.14.14.31;  author jhh;  state Exp;
  26. branches ;
  27. next     ;
  28.  
  29.  
  30. desc
  31. @@
  32.  
  33.  
  34. 1.4
  35. log
  36. @patchlevel 19
  37. @
  38. text
  39. @package DB;
  40.  
  41. # modified Perl debugger, to be run from Emacs in perldb-mode
  42. # Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  43. # Johan Vromans -- upgrade to 4.0 pl 10
  44.  
  45. $header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.2 $$Date: 91/11/05 17:55:58 $';
  46. #
  47. # This file is automatically included if you do perl -d.
  48. # It's probably not useful to include this yourself.
  49. #
  50. # Perl supplies the values for @@line and %sub.  It effectively inserts
  51. # a do DB'DB(<linenum>); in front of every place that can
  52. # have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
  53. #
  54. # Revision 4.0.1.2  91/11/05  17:55:58  lwall
  55. # patch11: perldb.pl modified to run within emacs in perldb-mode
  56. # 
  57. # Revision 4.0.1.1  91/06/07  11:17:44  lwall
  58. # patch4: added $^P variable to control calling of perldb routines
  59. # patch4: debugger sometimes listed wrong number of lines for a statement
  60. # 
  61. # Revision 4.0  91/03/20  01:25:50  lwall
  62. # 4.0 baseline.
  63. # 
  64. # Revision 3.0.1.6  91/01/11  18:08:58  lwall
  65. # patch42: @@_ couldn't be accessed from debugger
  66. # 
  67. # Revision 3.0.1.5  90/11/10  01:40:26  lwall
  68. # patch38: the debugger wouldn't stop correctly or do action routines
  69. # 
  70. # Revision 3.0.1.4  90/10/15  17:40:38  lwall
  71. # patch29: added caller
  72. # patch29: the debugger now understands packages and evals
  73. # patch29: scripts now run at almost full speed under the debugger
  74. # patch29: more variables are settable from debugger
  75. # 
  76. # Revision 3.0.1.3  90/08/09  04:00:58  lwall
  77. # patch19: debugger now allows continuation lines
  78. # patch19: debugger can now dump lists of variables
  79. # patch19: debugger can now add aliases easily from prompt
  80. # 
  81. # Revision 3.0.1.2  90/03/12  16:39:39  lwall
  82. # patch13: perl -d didn't format stack traces of *foo right
  83. # patch13: perl -d wiped out scalar return values of subroutines
  84. # 
  85. # Revision 3.0.1.1  89/10/26  23:14:02  lwall
  86. # patch1: RCS expanded an unintended $Header in lib/perldb.pl
  87. # 
  88. # Revision 3.0  89/10/18  15:19:46  lwall
  89. # 3.0 baseline
  90. # 
  91. # Revision 2.0  88/06/05  00:09:45  root
  92. # Baseline version 2.0.
  93. # 
  94. #
  95.  
  96. $tty = $ENV{"TTY"};
  97. open(IN, "<$tty") || open(IN,  "<&STDIN");    # so we don't dingle stdin
  98. open(OUT,">$tty") || open(OUT, ">&STDOUT");    # so we don't dongle stdout
  99. select(OUT);
  100. $| = 1;                # for DB'OUT
  101. select(STDOUT);
  102. $| = 1;                # for real STDOUT
  103. $sub = '';
  104.  
  105. # Is Perl being run from Emacs?
  106. $emacs = $main'ARGV[$[] eq '-emacs';
  107. shift(@@main'ARGV) if $emacs;
  108.  
  109. $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  110. print OUT "\nLoading DB routines from $header\n";
  111. print OUT ("Emacs support ",
  112.        $emacs ? "enabled" : "available",
  113.        ".\n");
  114. print OUT "\nEnter h for help.\n\n";
  115.  
  116. sub DB {
  117.     &save;
  118.     ($package, $filename, $line) = caller;
  119.     $usercontext = '($@@, $!, $[, $,, $/, $\) = @@saved;' .
  120.     "package $package;";        # this won't let them modify, alas
  121.     local($^P) = 0;            # don't debug our own evals
  122.     local(*dbline) = "_<$filename";
  123.     $max = $#dbline;
  124.     if (($stop,$action) = split(/\0/,$dbline{$line})) {
  125.     if ($stop eq '1') {
  126.         $signal |= 1;
  127.     }
  128.     else {
  129.         $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
  130.         $dbline{$line} =~ s/;9($|\0)/$1/;
  131.     }
  132.     }
  133.     if ($single || $trace || $signal) {
  134.     if ($emacs) {
  135.         print OUT "\032\032$filename:$line:0\n";
  136.     } else {
  137.         print OUT "$package'" unless $sub =~ /'/;
  138.         print OUT "$sub($filename:$line):\t",$dbline[$line];
  139.         for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
  140.         last if $dbline[$i] =~ /^\s*(}|#|\n)/;
  141.         print OUT "$sub($filename:$i):\t",$dbline[$i];
  142.         }
  143.     }
  144.     }
  145.     $evalarg = $action, &eval if $action;
  146.     if ($single || $signal) {
  147.     $evalarg = $pre, &eval if $pre;
  148.     print OUT $#stack . " levels deep in subroutine calls!\n"
  149.         if $single & 4;
  150.     $start = $line;
  151.       CMD:
  152.     while ((print OUT "  DB<", $#hist+1, "> "), $cmd=&gets) {
  153.         {
  154.         $single = 0;
  155.         $signal = 0;
  156.         $cmd eq '' && exit 0;
  157.         chop($cmd);
  158.         $cmd =~ s/\\$// && do {
  159.             print OUT "  cont: ";
  160.             $cmd .= &gets;
  161.             redo CMD;
  162.         };
  163.         $cmd =~ /^q$/ && exit 0;
  164.         $cmd =~ /^$/ && ($cmd = $laststep);
  165.         push(@@hist,$cmd) if length($cmd) > 1;
  166.         ($i) = split(/\s+/,$cmd);
  167.         eval "\$cmd =~ $alias{$i}", print OUT $@@ if $alias{$i};
  168.         $cmd =~ /^h$/ && do {
  169.             print OUT "
  170. T        Stack trace.
  171. s        Single step.
  172. n        Next, steps over subroutine calls.
  173. r        Return from current subroutine.
  174. c [line]    Continue; optionally inserts a one-time-only breakpoint 
  175.         at the specified line.
  176. <CR>        Repeat last n or s.
  177. l min+incr    List incr+1 lines starting at min.
  178. l min-max    List lines.
  179. l line        List line;
  180. l        List next window.
  181. -        List previous window.
  182. w line        List window around line.
  183. l subname    List subroutine.
  184. f filename    Switch to filename.
  185. /pattern/    Search forwards for pattern; final / is optional.
  186. ?pattern?    Search backwards for pattern.
  187. L        List breakpoints and actions.
  188. S        List subroutine names.
  189. t        Toggle trace mode.
  190. b [line] [condition]
  191.         Set breakpoint; line defaults to the current execution line; 
  192.         condition breaks if it evaluates to true, defaults to \'1\'.
  193. b subname [condition]
  194.         Set breakpoint at first line of subroutine.
  195. d [line]    Delete breakpoint.
  196. D        Delete all breakpoints.
  197. a [line] command
  198.         Set an action to be done before the line is executed.
  199.         Sequence is: check for breakpoint, print line if necessary,
  200.         do action, prompt user if breakpoint or step, evaluate line.
  201. A        Delete all actions.
  202. V [pkg [vars]]    List some (default all) variables in package (default current).
  203. X [vars]    Same as \"V currentpackage [vars]\".
  204. < command    Define command before prompt.
  205. > command    Define command after prompt.
  206. ! number    Redo command (default previous command).
  207. ! -number    Redo number\'th to last command.
  208. H -number    Display last number commands (default all).
  209. q or ^D        Quit.
  210. p expr        Same as \"print DB'OUT expr\" in current package.
  211. = [alias value]    Define a command alias, or list current aliases.
  212. command        Execute as a perl statement in current package.
  213.  
  214. ";
  215.             next CMD; };
  216.         $cmd =~ /^t$/ && do {
  217.             $trace = !$trace;
  218.             print OUT "Trace = ".($trace?"on":"off")."\n";
  219.             next CMD; };
  220.         $cmd =~ /^S$/ && do {
  221.             foreach $subname (sort(keys %sub)) {
  222.             print OUT $subname,"\n";
  223.             }
  224.             next CMD; };
  225.         $cmd =~ s/^X\b/V $package/;
  226.         $cmd =~ /^V$/ && do {
  227.             $cmd = 'V $package'; };
  228.         $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  229.             $packname = $1;
  230.             @@vars = split(' ',$2);
  231.             do 'dumpvar.pl' unless defined &main'dumpvar;
  232.             if (defined &main'dumpvar) {
  233.             &main'dumpvar($packname,@@vars);
  234.             }
  235.             else {
  236.             print DB'OUT "dumpvar.pl not available.\n";
  237.             }
  238.             next CMD; };
  239.         $cmd =~ /^f\b\s*(.*)/ && do {
  240.             $file = $1;
  241.             if (!$file) {
  242.             print OUT "The old f command is now the r command.\n";
  243.             print OUT "The new f command switches filenames.\n";
  244.             next CMD;
  245.             }
  246.             if (!defined $_main{'_<' . $file}) {
  247.             if (($try) = grep(m#^_<.*$file#, keys %_main)) {
  248.                 $file = substr($try,2);
  249.                 print "\n$file:\n";
  250.             }
  251.             }
  252.             if (!defined $_main{'_<' . $file}) {
  253.             print OUT "There's no code here anything matching $file.\n";
  254.             next CMD;
  255.             }
  256.             elsif ($file ne $filename) {
  257.             *dbline = "_<$file";
  258.             $max = $#dbline;
  259.             $filename = $file;
  260.             $start = 1;
  261.             $cmd = "l";
  262.             } };
  263.         $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
  264.             $subname = $1;
  265.             $subname = "main'" . $subname unless $subname =~ /'/;
  266.             $subname = "main" . $subname if substr($subname,0,1) eq "'";
  267.             ($file,$subrange) = split(/:/,$sub{$subname});
  268.             if ($file ne $filename) {
  269.             *dbline = "_<$file";
  270.             $max = $#dbline;
  271.             $filename = $file;
  272.             }
  273.             if ($subrange) {
  274.             if (eval($subrange) < -$window) {
  275.                 $subrange =~ s/-.*/+/;
  276.             }
  277.             $cmd = "l $subrange";
  278.             } else {
  279.             print OUT "Subroutine $1 not found.\n";
  280.             next CMD;
  281.             } };
  282.         $cmd =~ /^w\b\s*(\d*)$/ && do {
  283.             $incr = $window - 1;
  284.             $start = $1 if $1;
  285.             $start -= $preview;
  286.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  287.         $cmd =~ /^-$/ && do {
  288.             $incr = $window - 1;
  289.             $cmd = 'l ' . ($start-$window*2) . '+'; };
  290.         $cmd =~ /^l$/ && do {
  291.             $incr = $window - 1;
  292.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  293.         $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
  294.             $start = $1 if $1;
  295.             $incr = $2;
  296.             $incr = $window - 1 unless $incr;
  297.             $cmd = 'l ' . $start . '-' . ($start + $incr); };
  298.         $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  299.             $end = (!$2) ? $max : ($4 ? $4 : $2);
  300.             $end = $max if $end > $max;
  301.             $i = $2;
  302.             $i = $line if $i eq '.';
  303.             $i = 1 if $i < 1;
  304.             if ($emacs) {
  305.             print OUT "\032\032$filename:$i:0\n";
  306.             $i = $end;
  307.             } else {
  308.             for (; $i <= $end; $i++) {
  309.                 print OUT "$i:\t", $dbline[$i];
  310.                 last if $signal;
  311.             }
  312.             }
  313.             $start = $i;    # remember in case they want more
  314.             $start = $max if $start > $max;
  315.             next CMD; };
  316.         $cmd =~ /^D$/ && do {
  317.             print OUT "Deleting all breakpoints...\n";
  318.             for ($i = 1; $i <= $max ; $i++) {
  319.             if (defined $dbline{$i}) {
  320.                 $dbline{$i} =~ s/^[^\0]+//;
  321.                 if ($dbline{$i} =~ s/^\0?$//) {
  322.                 delete $dbline{$i};
  323.                 }
  324.             }
  325.             }
  326.             next CMD; };
  327.         $cmd =~ /^L$/ && do {
  328.             for ($i = 1; $i <= $max; $i++) {
  329.             if (defined $dbline{$i}) {
  330.                 print OUT "$i:\t", $dbline[$i];
  331.                 ($stop,$action) = split(/\0/, $dbline{$i});
  332.                 print OUT "  break if (", $stop, ")\n" 
  333.                 if $stop;
  334.                 print OUT "  action:  ", $action, "\n" 
  335.                 if $action;
  336.                 last if $signal;
  337.             }
  338.             }
  339.             next CMD; };
  340.         $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
  341.             $subname = $1;
  342.             $cond = $2 || '1';
  343.             $subname = "$package'" . $subname unless $subname =~ /'/;
  344.             $subname = "main" . $subname if substr($subname,0,1) eq "'";
  345.             ($filename,$i) = split(/[:-]/, $sub{$subname});
  346.             if ($i) {
  347.             *dbline = "_<$filename";
  348.             ++$i while $dbline[$i] == 0 && $i < $#dbline;
  349.             $dbline{$i} =~ s/^[^\0]*/$cond/;
  350.             } else {
  351.             print OUT "Subroutine $subname not found.\n";
  352.             }
  353.             next CMD; };
  354.         $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
  355.             $i = ($1?$1:$line);
  356.             $cond = $2 || '1';
  357.             if ($dbline[$i] == 0) {
  358.             print OUT "Line $i not breakable.\n";
  359.             } else {
  360.             $dbline{$i} =~ s/^[^\0]*/$cond/;
  361.             }
  362.             next CMD; };
  363.         $cmd =~ /^d\b\s*(\d+)?/ && do {
  364.             $i = ($1?$1:$line);
  365.             $dbline{$i} =~ s/^[^\0]*//;
  366.             delete $dbline{$i} if $dbline{$i} eq '';
  367.             next CMD; };
  368.         $cmd =~ /^A$/ && do {
  369.             for ($i = 1; $i <= $max ; $i++) {
  370.             if (defined $dbline{$i}) {
  371.                 $dbline{$i} =~ s/\0[^\0]*//;
  372.                 delete $dbline{$i} if $dbline{$i} eq '';
  373.             }
  374.             }
  375.             next CMD; };
  376.         $cmd =~ /^<\s*(.*)/ && do {
  377.             $pre = do action($1);
  378.             next CMD; };
  379.         $cmd =~ /^>\s*(.*)/ && do {
  380.             $post = do action($1);
  381.             next CMD; };
  382.         $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
  383.             $i = $1;
  384.             if ($dbline[$i] == 0) {
  385.             print OUT "Line $i may not have an action.\n";
  386.             } else {
  387.             $dbline{$i} =~ s/\0[^\0]*//;
  388.             $dbline{$i} .= "\0" . do action($3);
  389.             }
  390.             next CMD; };
  391.         $cmd =~ /^n$/ && do {
  392.             $single = 2;
  393.             $laststep = $cmd;
  394.             last CMD; };
  395.         $cmd =~ /^s$/ && do {
  396.             $single = 1;
  397.             $laststep = $cmd;
  398.             last CMD; };
  399.         $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
  400.             $i = $1;
  401.             if ($i) {
  402.             if ($dbline[$i] == 0) {
  403.                 print OUT "Line $i not breakable.\n";
  404.                 next CMD;
  405.             }
  406.             $dbline{$i} =~ s/(\0|$)/;9$1/;    # add one-time-only b.p.
  407.             }
  408.             for ($i=0; $i <= $#stack; ) {
  409.             $stack[$i++] &= ~1;
  410.             }
  411.             last CMD; };
  412.         $cmd =~ /^r$/ && do {
  413.             $stack[$#stack] |= 2;
  414.             last CMD; };
  415.         $cmd =~ /^T$/ && do {
  416.             local($p,$f,$l,$s,$h,$a,@@a,@@sub);
  417.             for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
  418.             @@a = @@args;
  419.             for (@@a) {
  420.                 if (/^StB\000/ && length($_) == length($_main{'_main'})) {
  421.                 $_ = sprintf("%s",$_);
  422.                 }
  423.                 else {
  424.                 s/'/\\'/g;
  425.                 s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
  426.                 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  427.                 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  428.                 }
  429.             }
  430.             $w = $w ? '@@ = ' : '$ = ';
  431.             $a = $h ? '(' . join(', ', @@a) . ')' : '';
  432.             push(@@sub, "$w&$s$a from file $f line $l\n");
  433.             last if $signal;
  434.             }
  435.             for ($i=0; $i <= $#sub; $i++) {
  436.             last if $signal;
  437.             print OUT $sub[$i];
  438.             }
  439.             next CMD; };
  440.         $cmd =~ /^\/(.*)$/ && do {
  441.             $inpat = $1;
  442.             $inpat =~ s:([^\\])/$:$1:;
  443.             if ($inpat ne "") {
  444.             eval '$inpat =~ m'."\n$inpat\n";    
  445.             if ($@@ ne "") {
  446.                 print OUT "$@@";
  447.                 next CMD;
  448.             }
  449.             $pat = $inpat;
  450.             }
  451.             $end = $start;
  452.             eval '
  453.             for (;;) {
  454.             ++$start;
  455.             $start = 1 if ($start > $max);
  456.             last if ($start == $end);
  457.             if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  458.                 if ($emacs) {
  459.                 print OUT "\032\032$filename:$start:0\n";
  460.                 } else {
  461.                 print OUT "$start:\t", $dbline[$start], "\n";
  462.                 }
  463.                 last;
  464.             }
  465.             } ';
  466.             print OUT "/$pat/: not found\n" if ($start == $end);
  467.             next CMD; };
  468.         $cmd =~ /^\?(.*)$/ && do {
  469.             $inpat = $1;
  470.             $inpat =~ s:([^\\])\?$:$1:;
  471.             if ($inpat ne "") {
  472.             eval '$inpat =~ m'."\n$inpat\n";    
  473.             if ($@@ ne "") {
  474.                 print OUT "$@@";
  475.                 next CMD;
  476.             }
  477.             $pat = $inpat;
  478.             }
  479.             $end = $start;
  480.             eval '
  481.             for (;;) {
  482.             --$start;
  483.             $start = $max if ($start <= 0);
  484.             last if ($start == $end);
  485.             if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  486.                 if ($emacs) {
  487.                 print OUT "\032\032$filename:$start:0\n";
  488.                 } else {
  489.                 print OUT "$start:\t", $dbline[$start], "\n";
  490.                 }
  491.                 last;
  492.             }
  493.             } ';
  494.             print OUT "?$pat?: not found\n" if ($start == $end);
  495.             next CMD; };
  496.         $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
  497.             pop(@@hist) if length($cmd) > 1;
  498.             $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
  499.             $cmd = $hist[$i] . "\n";
  500.             print OUT $cmd;
  501.             redo CMD; };
  502.         $cmd =~ /^!(.+)$/ && do {
  503.             $pat = "^$1";
  504.             pop(@@hist) if length($cmd) > 1;
  505.             for ($i = $#hist; $i; --$i) {
  506.             last if $hist[$i] =~ $pat;
  507.             }
  508.             if (!$i) {
  509.             print OUT "No such command!\n\n";
  510.             next CMD;
  511.             }
  512.             $cmd = $hist[$i] . "\n";
  513.             print OUT $cmd;
  514.             redo CMD; };
  515.         $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  516.             $end = $2?($#hist-$2):0;
  517.             $hist = 0 if $hist < 0;
  518.             for ($i=$#hist; $i>$end; $i--) {
  519.             print OUT "$i: ",$hist[$i],"\n"
  520.                 unless $hist[$i] =~ /^.?$/;
  521.             };
  522.             next CMD; };
  523.         $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
  524.         $cmd =~ /^=/ && do {
  525.             if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  526.             $alias{$k}="s~$k~$v~";
  527.             print OUT "$k = $v\n";
  528.             } elsif ($cmd =~ /^=\s*$/) {
  529.             foreach $k (sort keys(%alias)) {
  530.                 if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  531.                 print OUT "$k = $v\n";
  532.                 } else {
  533.                 print OUT "$k\t$alias{$k}\n";
  534.                 };
  535.             };
  536.             };
  537.             next CMD; };
  538.         }
  539.         $evalarg = $cmd; &eval;
  540.         print OUT "\n";
  541.     }
  542.     if ($post) {
  543.         $evalarg = $post; &eval;
  544.     }
  545.     }
  546.     ($@@, $!, $[, $,, $/, $\) = @@saved;
  547. }
  548.  
  549. sub save {
  550.     @@saved = ($@@, $!, $[, $,, $/, $\);
  551.     $[ = 0; $, = ""; $/ = "\n"; $\ = "";
  552. }
  553.  
  554. # The following takes its argument via $evalarg to preserve current @@_
  555.  
  556. sub eval {
  557.     eval "$usercontext $evalarg; &DB'save";
  558.     print OUT $@@;
  559. }
  560.  
  561. sub action {
  562.     local($action) = @@_;
  563.     while ($action =~ s/\\$//) {
  564.     print OUT "+ ";
  565.     $action .= &gets;
  566.     }
  567.     $action;
  568. }
  569.  
  570. sub gets {
  571.     local($.);
  572.     <IN>;
  573. }
  574.  
  575. sub catch {
  576.     $signal = 1;
  577. }
  578.  
  579. sub sub {
  580.     push(@@stack, $single);
  581.     $single &= 1;
  582.     $single |= 4 if $#stack == $deep;
  583.     if (wantarray) {
  584.     @@i = &$sub;
  585.     $single |= pop(@@stack);
  586.     @@i;
  587.     }
  588.     else {
  589.     $i = &$sub;
  590.     $single |= pop(@@stack);
  591.     $i;
  592.     }
  593. }
  594.  
  595. $single = 1;            # so it stops on first executable statement
  596. @@hist = ('?');
  597. $SIG{'INT'} = "DB'catch";
  598. $deep = 100;        # warning if stack gets this deep
  599. $window = 10;
  600. $preview = 3;
  601.  
  602. @@stack = (0);
  603. @@ARGS = @@ARGV;
  604. for (@@args) {
  605.     s/'/\\'/g;
  606.     s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  607. }
  608.  
  609. if (-f '.perldb') {
  610.     do './.perldb';
  611. }
  612. elsif (-f "$ENV{'LOGDIR'}/.perldb") {
  613.     do "$ENV{'LOGDIR'}/.perldb";
  614. }
  615. elsif (-f "$ENV{'HOME'}/.perldb") {
  616.     do "$ENV{'HOME'}/.perldb";
  617. }
  618.  
  619. 1;
  620. @
  621.  
  622.  
  623. 1.3
  624. log
  625. @got rid of $Log since rcs screws up on it
  626. @
  627. text
  628. @d3 5
  629. a7 1
  630. $header = '$RCSfile: perldb.pl,v $$Revision: 1.2 $$Date: 91/08/12 16:42:06 $';
  631. d16 36
  632. d53 3
  633. d67 4
  634. d72 5
  635. a76 1
  636. print OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
  637. d96 9
  638. a104 5
  639.     print OUT "$package'" unless $sub =~ /'/;
  640.     print OUT "$sub($filename:$line):\t",$dbline[$line];
  641.     for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
  642.         last if $dbline[$i] =~ /^\s*(;|}|#|\n)/;
  643.         print OUT "$sub($filename:$i):\t",$dbline[$i];
  644. d266 8
  645. a273 3
  646.             for (; $i <= $end; $i++) {
  647.             print OUT "$i:\t", $dbline[$i];
  648.             last if $signal;
  649. d420 5
  650. a424 1
  651.                 print OUT "$start:\t", $dbline[$start], "\n";
  652. d448 5
  653. a452 1
  654.                 print OUT "$start:\t", $dbline[$start], "\n";
  655. @
  656.  
  657.  
  658. 1.2
  659. log
  660. @sprite doesn't have /dev/tty
  661. @
  662. text
  663. @d3 1
  664. a3 1
  665. $header = '$RCSfile: perldb.pl,v $$Revision: 1.1 $$Date: 91/07/29 14:14:31 $';
  666. a11 40
  667. # $Log:    perldb.pl,v $
  668. # Revision 1.1  91/07/29  14:14:31  jhh
  669. # Initial revision
  670. #
  671. # Revision 4.0.1.1  91/06/07  11:17:44  lwall
  672. # patch4: added $^P variable to control calling of perldb routines
  673. # patch4: debugger sometimes listed wrong number of lines for a statement
  674. # 
  675. # Revision 4.0  91/03/20  01:25:50  lwall
  676. # 4.0 baseline.
  677. # 
  678. # Revision 3.0.1.6  91/01/11  18:08:58  lwall
  679. # patch42: @@_ couldn't be accessed from debugger
  680. # 
  681. # Revision 3.0.1.5  90/11/10  01:40:26  lwall
  682. # patch38: the debugger wouldn't stop correctly or do action routines
  683. # 
  684. # Revision 3.0.1.4  90/10/15  17:40:38  lwall
  685. # patch29: added caller
  686. # patch29: the debugger now understands packages and evals
  687. # patch29: scripts now run at almost full speed under the debugger
  688. # patch29: more variables are settable from debugger
  689. # 
  690. # Revision 3.0.1.3  90/08/09  04:00:58  lwall
  691. # patch19: debugger now allows continuation lines
  692. # patch19: debugger can now dump lists of variables
  693. # patch19: debugger can now add aliases easily from prompt
  694. # 
  695. # Revision 3.0.1.2  90/03/12  16:39:39  lwall
  696. # patch13: perl -d didn't format stack traces of *foo right
  697. # patch13: perl -d wiped out scalar return values of subroutines
  698. # 
  699. # Revision 3.0.1.1  89/10/26  23:14:02  lwall
  700. # patch1: RCS expanded an unintended $Header in lib/perldb.pl
  701. # 
  702. # Revision 3.0  89/10/18  15:19:46  lwall
  703. # 3.0 baseline
  704. # 
  705. # Revision 2.0  88/06/05  00:09:45  root
  706. # Baseline version 2.0.
  707. @
  708.  
  709.  
  710. 1.1
  711. log
  712. @Initial revision
  713. @
  714. text
  715. @d3 1
  716. a3 1
  717. $header = '$RCSfile: perldb.pl,v $$Revision: 4.0.1.1 $$Date: 91/06/07 11:17:44 $';
  718. d13 3
  719. d55 3
  720. a57 2
  721. open(IN, "</dev/tty") || open(IN,  "<&STDIN");    # so we don't dingle stdin
  722. open(OUT,">/dev/tty") || open(OUT, ">&STDOUT");    # so we don't dongle stdout
  723. @
  724.